HPAVC/HPAVC CD-ROM.iso/pc/AFVIEW.ZIP/AFVIEW.PAS

Pascal/Delphi Source File | 1995-03-01 | 12.5 KB | 387 lines

program afVIEW;

{$M $4000, 0, 0}

uses crt,dos;

type
   SegOfs = record           {structure of a pointer}
      Ofst, Segm : Word;
      end;

function Normalized(P : Pointer) : pointer; inline
   ($58/                    {pop ax    ;pop offset into AX}
   $5A/                     {pop dx    ;pop segment into DX}
   $89/$C3/                 {mov bx,ax ;BX = Ofs(P^)}
   $B1/$04/                 {mov cl,4  ;CL = 4}
   $D3/$EB/                 {shr bx,cl ;BX = Ofs(P^) div 16}
   $01/$DA/                 {add dx,bx ;add BX to segment}
   $25/$0F/$00);            {and ax,$F ;mask out unwanted bits in offset}

function Linear(P : Pointer) : LongInt;
   {-Converts a pointer to a linear address to allow differences in addresses
     to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.}
   begin
   with SegOfs(P) do
      Linear := (LongInt(Segm) shl 4)+LongInt(Ofst);
   end;

function LinearToPointer(L : LongInt) : Pointer;
   {-Return linear address L as a normalized pointer}
   begin
   LinearToPointer := Ptr(Word(L shr 4), Word(L and $0000000F));
   end;

function PtrDiff(P1, P2 : Pointer) : LongInt;
   {-Return the number of bytes between P1^ and P2^}
   begin
   PtrDiff := Abs(Linear(P1)-Linear(P2));
   end;

procedure HugeGetMem(var Pt; Bytes : LongInt);
   var
      P : Pointer absolute Pt;
      So : SegOfs absolute P;
      Paras : word;
   begin
   P:=Nil;
   Paras:=Bytes div 16;
   asm
   mov  bx, Paras
   mov  ah, 48h
   int  21h
   mov  Paras, 0
   jc   @end
   mov  Paras, ax
   @end:
   end;
   if Paras > 0 then So.Segm:=Paras;
   end;

procedure HugeFreeMem(var Pt; Bytes : LongInt);
    {-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer
      variable. Pt is set to nil on Exit. Does nothing if Pt is nil.}
   var
      P : Pointer absolute Pt;
      So : SegOfs absolute P;
      Tmp:word;
   begin
   {exit if P is nil}
   if (P = nil) then
      Exit;
   Tmp:=So.Segm;
   asm
   mov  es, Tmp
   mov  ah, 49h
   int  21h
   end;
   end;

procedure FillWord(var x; count:integer; w:word);
   begin
   Inline(
   $c4/$be/x/
   $8b/$86/w/
   $8b/$8e/count/
   $fc/
   $f2/$ab);
   (*  LES  DI,x              { load target address }
   MOV  AX,w              { load word to fill in }
   MOV  CX,count          { number of words to move }
   CLD                    { clear direction flag }
   REPNZ STOSW            { copy the data } *)
   end;

procedure LoadFile(FileN:string; Mem:pointer; NumL:word; var MaxLine:word);
   var
      CurLine:word;
      Tmp2:byte;
      TFileIn:file;
      AbsPtr:longint;
      TmpPtr:longint;
      TmpStr:array[1..8192] of char;
      Actual:word;
      Tmp:word;
      TmpBuf:pointer;
      Attr:byte; X,Y,SX,SY:word;
      AnsiLevel:byte;
      ParamCnt:byte;
      Params:array[1..10] of byte;
   procedure PutCh(Ch:char);
      begin
      case Ch of
         #8: begin
             if x>1 then
                begin
                dec(X);
                TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
                char(LinearToPointer(TmpPtr)^):=' ';
                byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
                end;
              end;
         #10: begin
              if Y < (NumL-1) then inc(Y);
              end;
         #13: begin
              X:=1;
              end;
         #1..#7,#11,#14..#255:
              begin
              TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
              char(LinearToPointer(TmpPtr)^):=Ch;
              byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
              inc(x); if X > 80 then begin X:=1; inc(Y); if y > (NumL-1) then dec(y) end;
              end;
         end;
      end;
   procedure SetColors;
      var
         Cntr : byte;
      begin
      for Cntr := 1 to ParamCnt do
         begin
         case Params[Cntr] of
         0 :  TextAttr := $07;
         1 :  TextAttr:=TextAttr or $08;{asm or Attr, 08h end;}
         5 :  TextAttr:=TextAttr or $80;{asm or Attr, 80h end;}
         7 :  asm
              mov  ax, word ptr TextAttr
              mov  bx, ax
              and  ax, 0707h
              xchg ah, al
              and  bx, 80h
              add  ax, bx
              mov  word ptr TextAttr, bx
              end;
         25 : TextAttr := (TextAttr AND (NOT $80)); {blink off}
         30 : TextAttr := (TextAttr AND $F8) + black;
         31 : TextAttr := (TextAttr AND $f8) + red;
         32 : TextAttr := (TextAttr AND $f8) + green;
         33 : TextAttr := (TextAttr AND $f8) + brown;
         34 : TextAttr := (TextAttr AND $f8) + blue;
         35 : TextAttr := (TextAttr AND $f8) + magenta;
         36 : TextAttr := (TextAttr AND $f8) + cyan;
         37 : TextAttr := (TextAttr AND $f8) + Lightgray;
         40 : TextAttr := (TextAttr AND $8F) + (black shl 4);
         41 : TextAttr := (TextAttr AND $8F) + (red shl 4);
         42 : TextAttr := (TextAttr AND $8F) + (green shl 4);
         43 : TextAttr := (TextAttr AND $8F) + (brown shl 4);
         44 : TextAttr := (TextAttr AND $8F) + (blue shl 4);
         45 : TextAttr := (TextAttr AND $8F) + (magenta shl 4);
         46 : TextAttr := (TextAttr AND $8F) + (cyan shl 4);
         47 : TextAttr := (TextAttr AND $8F) + (lightgray shl 4);
         end;
      end;
      end;
   begin
   Assign(TFileIn,FileN);
   Reset(TFileIn,1);
   AbsPtr:=Linear(Mem);
   for CurLine:=0 to NumL-1 do
      begin
      FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
      end;
   CurLine:=0;
   TextAttr:=$07;
   X:=1; Y:=1; AnsiLevel:=0; MaxLine:=1;
   repeat
      {ReadLn(TFileIn, TmpStr);}
      BlockRead(TFileIn, TmpStr, 4096, Actual);
      for Tmp:=1 to Actual do
         begin{
            TmpPtr:=AbsPtr+(longint(CurLine)*160)+(Tmp*2);
            char(LinearToPointer(TmpPtr)^):=TmpStr[Tmp+1];
            byte(LinearToPointer(TmpPtr+1)^):=$0F;}
            if TmpStr[Tmp]=#26 then break;
            case ANSILevel of
               0: begin
                  case TmpStr[Tmp] of
                     #27: ANSILevel := 1;
                     #9: if X < 80-8 then X:=( (X div 8) + 1 ) * 8;
                  else
                     PutCh(TmpStr[Tmp]);
                     end;
                  end;
               1: begin
                  if TmpStr[Tmp] = '[' then
                     begin
                     ANSILevel := 2;
                     ParamCnt := 1;
                     Params[1] := 0;
                     end
                  else
                     begin
                     {Write(#27+StIn[Cntr]);}
                     PutCH(TmpStr[Tmp]);
                     ANSILevel := 0;
                     end;
                  end;
               2: begin
                  case TmpStr[Tmp] of
                     '0'..'9': Params[ParamCnt]:=(Params[ParamCnt]*10)+(byte(TmpStr[Tmp])-48);
                     ';': begin
                          inc(ParamCnt);
                          Params[ParamCnt] := 0;
                          end;
                     'H',
                     'f': begin
                          if Params[2] > 80 then x:=80 else x:=Params[2];
                          if Params[1] > (NumL-1) then y:=NumL-1 else y:=Params[1];
                          ANSILevel := 0;
                          end;
                     'A': begin
                          if Params[1] = 0 then Params[1] := 1;
                          if (Y - Params[1]) < 1 then Y:=1 else Y:=Y - Params[1];
                          ANSILevel := 0;
                          end;
                     'B': begin
                          if Params[1] = 0 then Params[1] := 1;
                          if (Y + Params[1]) > (NumL-1) then Y:=NumL-1 else Y:=Y+Params[1];
                          ANSILevel := 0;
                          end;
                     'D': begin
                          if Params[1] = 0 then Params[1] := 1;
                          if (X - Params[1]) < 1 then X:=1 else X:=X - Params[1];
                          ANSILevel := 0;
                          end;
                     'C': begin
                          if Params[1] = 0 then Params[1] := 1;
                          if (X + Params[1]) > 80 then X:=80 else X:=X+Params[1];
                          ANSILevel := 0;
                          end;
                     'J': begin
                          case Params[1] of
                             0: for Tmp2:=X to 80 do
                                   begin
                                   TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((Tmp2-1)*2);
                                   char(LinearToPointer(TmpPtr)^):=' ';
                                   byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
                                   end;
                             1, {I just didn't bother today.}
                             2: begin
                                for CurLine:=0 to NumL-1 do
                                   FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
                                x:=1; y:=1;
                                end;
                             end;
                          ANSILevel := 0;
                          end;
                     'K': begin
                          for Tmp2:=X to 80 do
                             begin
                             TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
                             char(LinearToPointer(TmpPtr)^):=' ';
                             byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
                             end;
                          ANSILevel := 0;
                          end;
                     'm': begin
                          SetColors;
                          ANSILevel := 0;
                          end;
                     's': begin
                          SX:=X; SY:=Y;
                          ANSILevel := 0;
                          end;
                     'u': begin
                          X:=SX; Y:=SY;
                          ANSILevel := 0;
                          end;
                     end;
                  end;
               end;
            end;
      if y>MaxLine then MaxLine:=y;
   until eof(TFileIn) or (actual<4096);
   Close(TFileIn);
   end;

procedure Scroll(Ptr:pointer; NumL:word);
   var
      Done:boolean;
      CurLine:word;
      CurPtr:longint;
   begin
   Done:=False;
   CurPtr:=Linear(Ptr);
   CurLine:=0;
   TextAttr:=$7;
   ClrScr;
   repeat
      Move(LinearToPointer(CurPtr+(longint(CurLine)*160))^,Mem[$B800:$0000],160*25);
      GotoXY(77,1);
      Write(CurLine:4);
      case ReadKey of
         #0: case ReadKey of
                #71: CurLine:=0;
                #72: if CurLine>0 then dec(CurLine);
                #73: if (integer(CurLine)-25)>0 then dec(CurLine,25) else CurLine:=0;
                #79: CurLine:=NumL-25;
                #80: if CurLine+25<NumL then inc(CurLine);
                #81: if (CurLine+25+25)<NumL then inc(CurLine,25) else CurLine:=NumL-25;
                end;
         #27: Done:=True;
         end;
   until Done;
   end;

var videopage : byte;

{$L CurShape.OBJ}
function  getcursorshape : word; far; external;
procedure setcursorshape(scanlines : word); far; external;

procedure normalcursor;
   begin
   setcursorshape($0607);
   end;

procedure hidecursor;
  begin
  setcursorshape($2000);
  end;

var
   LngInt:longint;
   TmpPtr:pointer;
   NumLines:word;
   FileName:string;
   D : DirStr;
   N : NameStr;
   E : ExtStr;

const
   BuffLines=1500;
   BuffSize=BuffLines*160;

begin
videopage:=0;
WriteLn('afVIEW -- 1500 line Real Mode ANSi');
WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
if ParamCount<>1 then
   begin
   WriteLn(^J'Incorrect syntax, correct syntax:'^M^J^J'   AFVIEW FileName[.Ext]'^M^J^J+
           'The extension is optional and will be assumed to be .ANS');
   Halt(1);
   end;
FileName:=ParamStr(1);
FSplit(FileName,D,N,E);
if E='' then FileName:=FileName+'.ANS';
if FSearch(FileName,'')='' then
   begin
   WriteLn(ParamStr(1),' not found.');
   Halt(1);
   end;
HugeGetMem(TmpPtr,BuffSize);
if TmpPtr=nil then begin WriteLn('Memory allocation error.'); halt; end;
LoadFile(ParamStr(1),TmpPtr,BuffLines,NumLines);
HideCursor;
Scroll(TmpPtr,NumLines);
NormalCursor;
HugeFreeMem(TmpPtr,0);
TextAttr:=$07;
ClrScr;
WriteLn('afVIEW -- 1500 line Real Mode ANSi');
WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
end.